home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 5 / Apprentice-Release5.iso / Source Code / C / Applications / Moscow ML 1.31 / source code / mosml / src / mosmllib / Word.mlp < prev    next >
Encoding:
Text File  |  1996-07-03  |  4.0 KB  |  131 lines  |  [TEXT/R*ch]
  1. (* Word -- new basis 1994-11-01, 1995-04-06, 1995-07-12 *)
  2.  
  3. (* This unit relies on two's complement representation *)
  4.  
  5. prim_eqtype word;
  6.  
  7. #include "../config/m.h"
  8. #ifdef SIXTYFOUR
  9. #define WORDSIZE 63
  10. #else
  11. #define WORDSIZE 31
  12. #endif
  13.  
  14. val wordSize = WORDSIZE;
  15.  
  16. local
  17.     prim_val orb_       : word -> word -> word = 2 "or";
  18.     prim_val andb_      : word -> word -> word = 2 "and";
  19.     prim_val xorb_      : word -> word -> word = 2 "xor";
  20.     prim_val lshift_    : word -> word -> word = 2 "shift_left";
  21.     prim_val rshiftsig_ : word -> word -> word = 2 "shift_right_signed";
  22.     prim_val rshiftuns_ : word -> word -> word = 2 "shift_right_unsigned";
  23.     prim_val adduns_    : word -> word -> word = 2 "+intunsig";
  24.     prim_val subuns_    : word -> word -> word = 2 "-intunsig";
  25.     prim_val muluns_    : word -> word -> word = 2 "*intunsig";
  26.     prim_val divuns_    : word -> word -> word = 2 "divunsig";
  27.     prim_val moduns_    : word -> word -> word = 2 "modunsig";
  28.  
  29. in
  30.     prim_val wordToInt  : word -> int = 1 "identity";
  31.     prim_val signExtend : word -> int = 1 "identity";
  32.     prim_val intToWord  : int -> word = 1 "identity";
  33.  
  34.     fun orb (x, y)  = orb_ x y;
  35.     fun andb (x, y) = andb_ x y;
  36.     fun xorb (x, y) = xorb_ x y;
  37.     fun notb x      = xorb_ x (intToWord ~1); 
  38.  
  39.  
  40.     fun << (w, k) = 
  41.     if wordToInt k >= WORDSIZE orelse wordToInt k < 0 then intToWord 0
  42.     else lshift_ w k;
  43.  
  44.     fun >> (w, k) = 
  45.     if wordToInt k >= WORDSIZE orelse wordToInt k < 0 then intToWord 0
  46.     else rshiftuns_ w k;
  47.  
  48.     fun ~>> (w, k) = 
  49.     if wordToInt k >= WORDSIZE orelse wordToInt k < 0 then 
  50.         if wordToInt w >= 0 then    (* msbit = 0 *)
  51.         intToWord 0
  52.         else            (* msbit = 1 *)
  53.         intToWord ~1
  54.     else    
  55.         rshiftsig_ w k;
  56.  
  57.     fun w1  +  w2 = adduns_ w1 w2;
  58.     fun w1  -  w2 = subuns_ w1 w2;
  59.     fun w1  *  w2 = muluns_ w1 w2;
  60.     fun w1 div w2 = divuns_ w1 w2;
  61.     fun w1 mod w2 = moduns_ w1 w2;
  62.  
  63.     local 
  64.       open StringCvt
  65.       fun skipWSget getc source = getc (skipWS {getc=getc} source)
  66.  
  67.       (* Below, 48 = Char.ord #"0" and 55 = Char.ord #"A" - 10. *)
  68.       fun decval c = intToWord (Char.ord c) - intToWord 48;
  69.       fun hexval c = 
  70.       if #"0" <= c andalso c <= #"9" then 
  71.           intToWord (Char.ord c) - intToWord 48
  72.       else 
  73.           moduns_ (intToWord (Char.ord c) - intToWord 55) (intToWord 32);
  74.  
  75.       fun prhex i = 
  76.       if wordToInt i < 10 then Char.chr(wordToInt (i + intToWord 48))
  77.       else Char.chr(wordToInt (i + intToWord 55));
  78.  
  79.       fun conv radix i = 
  80.       let fun h n res = 
  81.           if n = intToWord 0 then res
  82.           else h (divuns_ n radix) (prhex (moduns_ n radix) :: res)
  83.           fun tostr n = h (divuns_ n radix) [prhex (moduns_ n radix)]
  84.       in String.implode (tostr i) end
  85.  
  86.     in
  87.       fun scan radix {getc} source =
  88.       let open StringCvt
  89.           val (isDigit, factor) = 
  90.           case radix of
  91.               BIN => (fn c => (#"0" <= c andalso c <= #"1"),  2)
  92.             | OCT => (fn c => (#"0" <= c andalso c <= #"7"),  8)
  93.             | DEC => (Char.isDigit,                          10)
  94.             | HEX => (Char.isHexDigit,                       16)
  95.           fun dig1 NONE             = NONE
  96.         | dig1 (SOME (c, rest)) = 
  97.           let fun digr res src = 
  98.               case getc src of
  99.               NONE           => SOME (res, src)
  100.             | SOME (c, rest) => 
  101.                   if isDigit c then 
  102.                   digr (intToWord factor * res + hexval c) rest
  103.                   else 
  104.                   SOME (res, src)
  105.           in 
  106.               if isDigit c then digr (hexval c) rest 
  107.               else NONE 
  108.           end
  109.       in dig1 (skipWSget getc source) end;
  110.  
  111.       fun fmt BIN = conv (intToWord  2)
  112.     | fmt OCT = conv (intToWord  8)
  113.     | fmt DEC = conv (intToWord 10)
  114.     | fmt HEX = conv (intToWord 16)
  115.  
  116.       fun toString w   = conv (intToWord 16) w
  117.       fun fromString s = scanString (scan HEX) s
  118.     end (* local for string functions *)
  119.  
  120.     val op > = fn (w1, w2) =>
  121.     if wordToInt w1 >= 0 then 
  122.         wordToInt w2 >= 0 andalso wordToInt w1 > wordToInt w2
  123.     else
  124.         wordToInt w2 >= 0 orelse  wordToInt w1 > wordToInt w2;
  125.     fun w1 < w2  = w2 > w1;
  126.     fun w1 >= w2 = not (w1 < w2);
  127.     fun w1 <= w2 = not (w1 > w2);
  128.     fun compare (x, y: word) = 
  129.     if x<y then LESS else if x>y then GREATER else EQUAL;
  130. end
  131.